;;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Base:8; Readtable:ZL -*-

(defvar %sys-com-band-crc #o35)

(defun read-band-crc (part &optional (unit 0))
  (with-decoded-disk-unit (unit unit "read")
    (with-disk-rqb (rqb)
      (let ((part-base (find-disk-partition-for-read part nil unit)))
        (disk-read rqb unit (+ part-base 1))
        (let ((lo (aref (rqb-buffer rqb) (* %sys-com-band-crc 2)))
              (hi (aref (rqb-buffer rqb) (1+ (* %sys-com-band-crc 2)))))
          (let ((crc (dpb hi (byte 16. 16.) lo)))
            (if (not (zerop (ldb %%q-cdr-code crc)))
                (ferror nil "cdr of crc word is not 0"))
            (if (not (= (ldb %%q-data-type crc) dtp-fix))
                (ferror nil "data type of crc word is not DTP-FIX"))
            (%make-pointer-unsigned crc)))))))

(defun write-band-crc (val part &optional (unit 0))
  (if (not (zerop (ldb %%q-cdr-code val)))
      (ferror nil "cdr-code must be 0"))
  (if (not (= (ldb %%q-data-type val) dtp-fix))
      (ferror nil "must be DTP-FIX"))
  (with-decoded-disk-unit (unit unit "write")
    (with-disk-rqb (rqb)
      (let ((first-block (find-disk-partition-for-write part nil unit)))
        (disk-read rqb unit (+ first-block 1))
        (aset (ldb (byte 16. 0) val) (rqb-buffer rqb) (* %sys-com-band-crc 2))
        (aset (ldb (byte 16. 16.) val) (rqb-buffer rqb) (1+ (* %sys-com-band-crc 2)))
        (disk-write rqb unit (+ first-block 1)))))
  val)

;compute-region-crc
;       ((vma-start-read) m-1)
;       (illop-if-page-fault)
;       ((m-tem) ldb (byte 16. 0) md)
;       ((a-band-crc-accumulator) add m-tem a-band-crc-accumulator)
;       ((m-tem) ldb (byte 1 16.) a-band-crc-accumulator)
;       ((a-band-crc-accumulator) add m-tem a-band-crc-accumulator)
;       ((m-tem) ldb (byte 16. 16.) md)
;       ((a-band-crc-accumulator) add m-tem a-band-crc-accumulator)
;       ((m-tem) ldb (byte 1 16.) a-band-crc-accumulator)
;       ((a-band-crc-accumulator) add m-tem a-band-crc-accumulator)
;       ((m-1) add m-1 (a-constant 1))
;       ((m-2) sub m-2 (a-constant 1))
;       (jump-not-equal m-2 a-zero compute-band-crc)
;       (popj)

(defvar band-crc-accumulator)

(defun compute-region-crc (array nwords)
  (do ((adr 0 (+ adr 2))
       (end (* nwords 2))
       x)
      ((= adr end))
    (setq x (aref array adr))
    (incf band-crc-accumulator x)
    (setq x (ldb (byte 1 16.) band-crc-accumulator))
    (incf band-crc-accumulator x)
    (setq x (aref array (1+ adr)))
    (incf band-crc-accumulator x)
    (setq x (ldb (byte 1 16.) band-crc-accumulator))
    (incf band-crc-accumulator x)
    (setq band-crc-accumulator (ldb (byte 16. 0) band-crc-accumulator))
    (cerror :no-action nil nil "foo")))

(defun compute-region-crc (array nwords)
  (do ((adr 0 (+ adr 2))
       (end (* nwords 2))
       (x band-crc-accumulator))
      ((= adr end)
       (setq band-crc-accumulator x))
    (setq x (+ (aref array adr) x))
    (setq x (+ x (ldb (byte 1 16.) x)))
    (setq x (+ x (aref array (1+ adr))))
    (setq x (ldb (byte 16. 0) (+ x (ldb (byte 1 16.) x))))
    (cerror :no-action nil nil "foo")
    ))


(defun compute-band-crc (part &optional (unit 0) &aux blocks-to-go (rqb-blocks 100.))
  (setq blocks-to-go (measured-size-of-partition part unit))
  (with-decoded-disk-unit (unit unit "read")
    (with-disk-rqb (rqb rqb-blocks)
      (multiple-value-bind (part-base n-blocks)
          (find-disk-partition-for-read part nil unit)
        (if (< n-blocks blocks-to-go)
            (ferror nil "partition is ~d. long but band says it's ~d. long"
                    n-blocks blocks-to-go))
        (disk-read rqb unit part-base)
        (aset 0 (rqb-buffer rqb) (* (+ 400 %sys-com-band-crc) 2))
        (aset (ash (dpb dtp-fix %%q-data-type 0) -16.) (rqb-buffer rqb) (1+ (* (+ 400 %sys-com-band-crc) 2)))
        (setq band-crc-accumulator 0)
        (compute-region-crc (rqb-buffer rqb) (* page-size 3))
 (cerror :no-action nil nil "foo")
        (decf blocks-to-go 3)
        (if (<= blocks-to-go 0)
            (ferror nil "invalid band size"))
        (do ((block-offset 3))
            ((zerop blocks-to-go))
          (format t "~d " blocks-to-go)
          (disk-read rqb unit block-offset)
          (let ((blocks-this-time (min blocks-to-go rqb-blocks)))
            (compute-region-crc (rqb-buffer rqb) (* blocks-this-time 400))
            (incf block-offset blocks-this-time)
            (decf blocks-to-go blocks-this-time))))))
  (write-band-crc (dpb dtp-fix %%q-data-type (%make-pointer-unsigned band-crc-accumulator))
                  part unit)
  )
